home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / debug.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  4.4 KB  |  135 lines
  1. ;;;;     Copyright (C) 1996, 1997, 1998, 1999, 2001, 2006 Free Software Foundation
  2. ;;;; 
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 2.1 of the License, or (at your option) any later version.
  7. ;;;; 
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;;;
  17. ;;;; The author can be reached at djurfeldt@nada.kth.se
  18. ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  19. ;;;;
  20.  
  21.  
  22. (define-module (ice-9 debug)
  23.   :export (frame-number->index trace untrace trace-stack untrace-stack))
  24.  
  25.  
  26. ;;; {Misc}
  27. ;;;
  28. (define (frame-number->index n . stack)
  29.   (let ((stack (if (null? stack)
  30.            (fluid-ref the-last-stack)
  31.            (car stack))))
  32.     (if (memq 'backwards (debug-options))
  33.     n
  34.     (- (stack-length stack) n 1))))
  35.  
  36.  
  37. ;;; {Trace}
  38. ;;;
  39. ;;; This code is just an experimental prototype (e. g., it is not
  40. ;;; thread safe), but since it's at the same time useful, it's
  41. ;;; included anyway.
  42. ;;;
  43. (define traced-procedures '())
  44.  
  45. (define (trace . args)
  46.   (if (null? args)
  47.       (nameify traced-procedures)
  48.       (begin
  49.     (for-each (lambda (proc)
  50.             (if (not (procedure? proc))
  51.             (error "trace: Wrong type argument:" proc))
  52.             (set-procedure-property! proc 'trace #t)
  53.             (if (not (memq proc traced-procedures))
  54.             (set! traced-procedures
  55.                   (cons proc traced-procedures))))
  56.           args)
  57.     (trap-set! apply-frame-handler trace-entry)
  58.     (trap-set! exit-frame-handler trace-exit)
  59.     ;; We used to reset `trace-level' here to 0, but this is wrong
  60.     ;; if `trace' itself is being traced, since `trace-exit' will
  61.     ;; then decrement `trace-level' to -1!  It shouldn't actually
  62.     ;; be necessary to set `trace-level' here at all.
  63.     (debug-enable 'trace)
  64.     (nameify args))))
  65.  
  66. (define (untrace . args)
  67.   (if (and (null? args)
  68.        (not (null? traced-procedures)))
  69.       (apply untrace traced-procedures)
  70.       (begin
  71.     (for-each (lambda (proc)
  72.             (set-procedure-property! proc 'trace #f)
  73.             (set! traced-procedures (delq! proc traced-procedures)))
  74.           args)
  75.     (if (null? traced-procedures)
  76.         (debug-disable 'trace))
  77.     (nameify args))))
  78.  
  79. (define (nameify ls)
  80.   (map (lambda (proc)
  81.      (let ((name (procedure-name proc)))
  82.        (or name proc)))
  83.        ls))
  84.  
  85. (define trace-level 0)
  86. (add-hook! abort-hook (lambda () (set! trace-level 0)))
  87.  
  88. (define traced-stack-ids (list 'repl-stack))
  89. (define trace-all-stacks? #f)
  90.  
  91. (define (trace-stack id)
  92.   "Add ID to the set of stack ids for which tracing is active.
  93. If `#t' is in this set, tracing is active regardless of stack context.
  94. To remove ID again, use `untrace-stack'.  If you add the same ID twice
  95. using `trace-stack', you will need to remove it twice."
  96.   (set! traced-stack-ids (cons id traced-stack-ids))
  97.   (set! trace-all-stacks? (memq #t traced-stack-ids)))
  98.  
  99. (define (untrace-stack id)
  100.   "Remove ID from the set of stack ids for which tracing is active."
  101.   (set! traced-stack-ids (delq1! id traced-stack-ids))
  102.   (set! trace-all-stacks? (memq #t traced-stack-ids)))
  103.  
  104. (define (trace-entry key cont tail)
  105.   (if (or trace-all-stacks?
  106.       (memq (stack-id cont) traced-stack-ids))
  107.       (let ((cep (current-error-port))
  108.         (frame (last-stack-frame cont)))
  109.     (if (not tail)
  110.         (set! trace-level (+ trace-level 1)))
  111.     (let indent ((n trace-level))
  112.       (cond ((> n 1) (display "|  " cep) (indent (- n 1)))))
  113.     (display-application frame cep)
  114.     (newline cep)))
  115.   ;; It's not necessary to call the continuation since
  116.   ;; execution will continue if the handler returns
  117.   ;(cont #f)
  118.   )
  119.  
  120. (define (trace-exit key cont retval)
  121.   (if (or trace-all-stacks?
  122.       (memq (stack-id cont) traced-stack-ids))
  123.       (let ((cep (current-error-port)))
  124.     (set! trace-level (- trace-level 1))
  125.     (let indent ((n trace-level))
  126.       (cond ((> n 0) (display "|  " cep) (indent (- n 1)))))
  127.     (write retval cep)
  128.     (newline cep))))
  129.  
  130.  
  131. ;;; A fix to get the error handling working together with the module system.
  132. ;;;
  133. ;;; XXX - Still needed?
  134. (module-set! the-root-module 'debug-options debug-options)
  135.